home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
turbovis
/
dlgds411.zip
/
PASSRC1.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-01-02
|
15KB
|
576 lines
{$A-,B-,E+,F-,G-,I+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
{$M 16384,5000,655360}
Program PasSrc1;
uses Dos, Objects, {Drivers, Views, Dialogs,
Editors, Validate,} Dialogs, ReadScpt;
const
(* dpBlueDialog = 0;
dpCyanDialog = 1;
dpGrayDialog = 2; *)
NeedControl1 : boolean = False;
var
P : PScriptRec;
Outf : Text;
DlgName : string[50]; {holds dialog's variable name for easy reference}
function Positn(Pat, Src : String; I : Integer) : Integer;
{find the position of a substring in a string starting at the Ith char}
var
N : Integer;
begin
if I < 1 then I := 1;
Delete(Src, 1, I-1);
N := Pos(Pat, Src);
if N = 0 then Positn := 0
else Positn := N+I-1;
end;
FUNCTION Quoted(S : string) : string;
{If first char is '@' then removes the '@' and otherwise does nothing--
assumes string is a variable name.
else
Puts single quotes around a string and doubles any internal single quotes}
var
I : Integer;
begin
I := Pos('@', S);
if I = 1 then
begin
Quoted := Copy(S, 2, 255);
Exit;
end;
I := Pos('''', S);
while I > 0 do
begin
Insert('''', S, I);
I := Positn('''', S, I+2);
end;
Insert('''', S, 1);
Quoted := S+'''';
end;
procedure RDotAssign(P : PScriptRec);
begin
with P^.MainBlock do
begin
WriteLn(Outf, 'R.Assign(', X1, ', ', Y1, ', ', X2,', ', Y2, ');');
end;
end;
procedure DoOpEvent(P : PScriptRec; const Sym : string);
var
S : string;
begin
with P^.MainBlock do
begin
if DefOptns <> Optns then
begin
Write(Outf, Sym, '^.Options := ');
S := OptionStr(Optns, DefOptns, GetOptionWords);
if S[1] = '$' then
WriteLn(OutF, S)
else WriteLn(OutF, Sym, '^.Options', S);
end;
if DefEvMsk <> EvMsk then
begin
Write(Outf, Sym, '^.EventMask := ');
S := OptionStr(EvMsk, DefEvMsk, GetEventWords);
if S[1] = '$' then
WriteLn(OutF, S)
else WriteLn(OutF, Sym, '^.EventMask', S);
end;
end;
end;
PROCEDURE WriteHelpCtx(Rf : PString; H : String; Ctx : word);
Const
NoContext : String[11] = 'hcNoContext';
begin
if (H = '') and (Ctx > 0) then
Str(Ctx, H);
if (H <> '') and not SameString(H, NoContext) then
WriteLn(OutF, Rf^, '^.HelpCtx := ', H, ';' );
end;
procedure WriteButton(P : PScriptRec); {write code for TButton}
var
S : string[55];
function FlagStr : string;
var
S : string[55];
begin
with P^ do
begin
S := '';
if Flags = 0 then S := 'bfNormal'
else
begin
if Flags and 1 <> 0 then S := 'bfDefault or ';
if Flags and 2 <> 0 then S := S+'bfLeftJust or ';
if Flags and 4 <> 0 then S := S+'bfBroadcast or ';
if Flags and 8 <> 0 then S := S+'bfGrabFocus or ';
Dec(S[0], 4); {remove extra ' or '}
end;
end;
FlagStr := S;
end;
begin
with P^, MainBlock do
begin
RDotAssign(P);
if SameString(Obj^, 'POptionButton') then {a special TOptionButton}
WriteLn(OutF, VarName^, ' := New(', Obj^, ', Init(R, ', Param[1]^,
', '+Param[2]^+'));' )
else
begin {regular button}
if CommandName^ <> '' then S := CommandName^
else Str(CommandValue, S);
Write(OutF, VarName^, ' := New(', Obj^, ', Init(R, ',
Quoted(ButtonText^), ', '+S+', ' );
WriteLn(OutF, FlagStr+'));' );
end;
WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
DoOpEvent(P, VarName^);
WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
end;
end;
procedure WriteInputLong(P : PScriptRec); {code for TInputLong}
begin
with P^, MainBlock do
begin
RDotAssign(P);
WriteLn(OutF,
VarName^, ' := New('+Obj^+', Init(R, ', LongStrLeng,
', ', LLim, ', ', ULim, ', ', ILOptions, '));' );
WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
DoOpEvent(P, VarName^);
WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
end;
end;
procedure WriteInputLine(P : PScriptRec); {code for TInputLine}
var
S : string[15];
function DoubleInsideQuotes(St : string) : string;
var
I : integer;
begin
I := Pos('''', St);
while I > 0 do
begin
Insert('''', St, I);
I := Positn('''', St, I+2);
end;
DoubleInsideQuotes := St;
end;
begin
with P^, MainBlock do
begin
RDotAssign(P);
WriteLn(OutF,
VarName^, ' := New('+Obj^+', Init(R, ', StringLeng, '));' );
WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
DoOpEvent(P, VarName^);
WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
if ValKind in [Picture..StringLookup] then
begin
Write(OutF, ' ', Obj^+'('+VarName^+')^.Validator := New(', ValPtrName^,
', Init(');
case ValKind of
Picture:
begin
if AutoFill <> 0 then S := 'True' else S := 'False';
{Note: PictureString may start with '@'}
WriteLn(OutF, '''', DoubleInsideQuotes(PictureString^), ''', ', S, '));');
end;
Range:
begin
WriteLn(OutF, LowLim, ', ', UpLim, '));');
if Transfer <> 0 then
WriteLn(OutF, ' ',
Obj^+'('+VarName^+')^.Validator^.Options := voTransfer;');
end;
Filter:
WriteLn(OutF, CharSet^, '));');
StringLookup:
WriteLn(OutF, List^, '));');
end;
end;
end;
end;
procedure WriteMemo(P : PScriptRec);
begin
with P^, MainBlock do
begin
RDotAssign(P);
Write(OutF,
VarName^, ' := New('+Obj^+', Init(R, ');
if HScroll^ <> '' then
Write(OutF, 'PScrollbar(Control1), ')
else Write(OutF, 'Nil, ' );
if VScroll^ <> '' then
Write(OutF, 'PScrollbar(Control), ')
else Write(OutF, 'Nil, ' );
WriteLn(OutF, 'Nil, ', BufSize, '));');
WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
DoOpEvent(P, VarName^);
WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
end;
end;
procedure WriteListBox(P : PScriptRec);
begin
with P^, MainBlock do
begin
RDotAssign(P);
Write(OutF,
VarName^, ' := New('+Obj^+', Init(R, ', Columns);
if Scrollbar^ <> '' then
WriteLn(OutF, ', PScrollbar('+ScrollBar^+')));')
else WriteLn(OutF, ', Nil));' );
WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
DoOpEvent(P, VarName^);
WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
end;
end;
procedure WriteScrollBar(P : PScriptRec);
begin
with P^, MainBlock do
begin
RDotAssign(P);
WriteLn(OutF,
VarName^, ' := New('+Obj^+', Init(R));');
WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
DoOpEvent(P, VarName^);
WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
end;
end;
procedure WriteCheckRadio(P : PScriptRec);
var
I : integer;
function MCBFlagString(Flags : word) : string;
var
S : string[30];
begin
if Flags = $101 then S := 'cfOneBit'
else if Flags = $203 then S := 'cfTwoBits'
else if Flags = $40F then S := 'cfFourBits'
else if Flags = $8FF then S := 'cfEightBits'
else S := '$'+Hex4(Flags);
MCBFlagString := S;
end;
begin
with P^, MainBlock do
begin
RDotAssign(P);
Write(OutF,
VarName^, ' := New('+Obj^+', Init(R, ');
for I := 0 to Items-1 do
Write(OutF, ^M^J' NewSItem(', Quoted(PString(LabelColl^.At(I))^), ',');
Write(OutF, ' Nil)');
for I := 1 to Items-1 do
Write(OutF, ')');
if Kind = MultiCB then
Write(OutF, ', ', SelRange, ', ', MCBFlagString(MCBFlags), ', ', Quoted(States^));
WriteLn(OutF, '));');
if Mask <> -1 then
WriteLn(OutF, 'PCluster('+VarName^+')^.SetButtonState($', Hex8(not Mask), ', False);');
WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
DoOpEvent(P, VarName^);
WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
end;
end;
procedure WriteHistory(P : PScriptRec);
begin
with P^, MainBlock do
begin
Write(OutF, ' ');
RDotAssign(P);
WriteLn(OutF, ' ', DlgName, '^.Insert(New(PHistory, Init(R, PInputline(',
HistoryLink^, '), ', HistoryID, ')));');
end;
end;
procedure WriteStaticText(P : PScriptRec);
procedure DoAtText;
var
S : string;
I : integer;
begin
S := P^.Text^;
I := Pos(^C, S);
while I > 0 do
begin